home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Franz PD / Franz PD Disk #185 (199x)(Rhein-Sieg-Soft).zip / Franz PD Disk #185 (199x)(Rhein-Sieg-Soft).adf / Source / Source
Text File  |  1992-07-20  |  42KB  |  1,658 lines
  1. '                         ***************************
  2. '                         *                         *
  3. '                         *  PLANETARIUMSIMULATION  *
  4. '                         *        Vers. 1.13i      *
  5. '                         ***************************
  6. ' ==============================================================================
  7. '                          H A U P T P R O G R A M M
  8. ' ==============================================================================
  9. $S>
  10. $S&
  11. ON BREAK GOSUB closeprogram
  12. CLS
  13. @titlescreen
  14. @init
  15. DELAY 5
  16. @fade
  17. CLOSES 7
  18. @start
  19. WHILE end&=0
  20.   IF end&=0 THEN
  21.     ON cont& GOSUB starchart,planetarium
  22.   ENDIF
  23. WEND
  24. @closeprogram
  25. EDIT
  26. ' ==============================================================================
  27. '                          P R O G R A M M - M O D U L E
  28. ' ==============================================================================
  29. PROCEDURE titlescreen
  30.   DIM plane%(8),plane$(8)
  31.   pfad$=DIR$(0)
  32.   @load_acbm(pfad$+"planetarium.pic",99)          ! load graphics to screen
  33.   DISPLAY ON
  34. RETURN
  35. '  -----------------------------------
  36. PROCEDURE setcol1
  37.   SETCOLOR 0,0,0,0       ! black
  38.   SETCOLOR 1,15,15,15    ! white
  39.   SETCOLOR 2,15,15,4     ! light yellow
  40.   SETCOLOR 3,15,3,3      ! light red
  41.   SETCOLOR 4,8,8,15      ! light blue
  42.   SETCOLOR 5,14,5,0      ! intensif red
  43.   SETCOLOR 6,15,12,10    ! ochre
  44.   SETCOLOR 7,1,1,3       ! dark blue
  45. RETURN
  46. '  -----------------------------------
  47. PROCEDURE setcol2
  48.   SETCOLOR 0,1,1,2       ! dark blue
  49.   SETCOLOR 1,14,5,0      ! intensif red
  50.   SETCOLOR 2,15,15,4     ! light yellow
  51.   SETCOLOR 3,15,15,15    ! white
  52.   SETCOLOR 4,15,15,15    ! white
  53.   SETCOLOR 5,11,11,11    ! gray1
  54.   SETCOLOR 6,8,8,8       ! gray2
  55.   SETCOLOR 7,5,5,5       ! gray3
  56. RETURN
  57. '  -----------------------------------
  58. PROCEDURE fade
  59.   FOR color&=0 TO 10
  60.     fade&=(15/10)*color&
  61.     FOR pal&=1 TO cols&
  62.       SETCOLOR pal&,15-fade&,15-fade&,15
  63.     NEXT pal&
  64.   NEXT color&
  65.   FOR color&=0 TO 10
  66.     fade&=(15/10)*color&
  67.     FOR pal&=1 TO cols&
  68.       SETCOLOR pal&,0,0,15-fade&
  69.     NEXT pal&
  70.   NEXT color&
  71. RETURN
  72. '  ===================================
  73. PROCEDURE init
  74.   end&=0
  75.   presetloc&=1       ! pre-set location
  76.   @presetloc
  77.   s_time!=TRUE       ! set system-time
  78.   sim!=FALSE         ! forces creation of whole screen
  79.   tele!=FALSE        ! Teleskope switched off
  80.   in_chart!=FALSE    ! display names on border
  81.   avail&=0           ! counter for available telescope objects
  82.   mode&=1            ! Defaultmode starchart
  83.   resolution&=2      ! Defaul Hires Lace
  84.   hori&=640
  85.   verti&=256
  86.   i1&=239       ! i1&=number of stars
  87.   i2&=240
  88.   i3&=50        ! i3&=number of constellations
  89.   f=1
  90.   datum$=SPACE$(10)
  91.   format$=SPACE$(18)
  92.   format1$=SPACE$(26)
  93.   year$=RIGHT$(DATE$,4)
  94.   IF MID$(DATE$,3,1)="." THEN
  95.     day$=LEFT$(DATE$,2)
  96.     month$=MID$(DATE$,4,2)
  97.   ELSE
  98.     day$=LEFT$(DATE$)
  99.     month$=MID$(DATE$,3,2)
  100.   ENDIF
  101.   interval$="2"      ! Presets for
  102.   delay$="6"         ! planetarium mode
  103.   DIM z$(i3&,1),z&(i3&,1)
  104.   DIM fpos&(i2&,1),p(11),re(i2&),de(i2&),fstern$(i2&)
  105.   DIM const&(i2&),lk(i2&)
  106.   DIM plan$(5),tb(5),ep(5),ph(5),mp(5),e(5),kn(5),i(5),ae(5)
  107.   DIM plpos&(5,1)
  108.   DIM men$(40)
  109.   DIM avail$(20)
  110.   DIM moon$(2)
  111.   moon$(2)=SPACE$(708)                ! Strings für bmove auf die
  112.   moon$(1)=SPACE$(348)                ! richtige Länge bringen
  113.   ' ----------------------------------------------------------------
  114.   ' picture of the moon
  115.   '
  116.   INLINE moon2%,708
  117.   INLINE moon1%,348
  118.   BMOVE moon2%,V:moon$(2),708               ! HiRes Lace
  119.   BMOVE moon1%,V:moon$(1),348               ! HiRes
  120.   '
  121.   ' read data
  122.   '
  123.   RESTORE constellations
  124.   FOR i&=0 TO i3&
  125.     READ z$(i&,0),z$(i&,1),z&(i&,0),z&(i&,1)
  126.   NEXT i&
  127.   RESTORE fstars
  128.   FOR s&=1 TO i1&
  129.     READ re(s&)
  130.     READ de(s&)
  131.     READ fstern$(s&)
  132.     READ const&(s&)
  133.     READ lk(s&)
  134.   NEXT s&
  135.   RESTORE planets
  136.   FOR p&=0 TO 5
  137.     READ plan$(p&),tb(p&),ep(p&),ph(p&),mp(p&),e(p&),kn(p&),i(p&),ae(p&)
  138.   NEXT p&
  139.   RESTORE availobjects
  140.   REPEAT
  141.     INC avail&
  142.     READ avail$(avail&)
  143.   UNTIL avail$(avail&)="ENDE"
  144.   DEC avail&
  145.   ' ----------------------------------------------------------------
  146.   '  ** funktions **
  147.   DEFFN mo(x)=x-INT(x/360)*360     ! special modulo for angles
  148. RETURN
  149. '  ===================================
  150. PROCEDURE presetloc
  151.   ON presetloc& GOSUB wuennenberg,berlin,moskow,new_york,arctic,antarctic,quito
  152. RETURN
  153. '  ===================================
  154. PROCEDURE systemtime
  155.   LSET datum$=DATE$
  156.   localtime$=TIME$
  157. RETURN
  158. '  -----------------------------------
  159. PROCEDURE start
  160.   CLOSES 1
  161.   OPENS 1,0,0,640,256,3,32768
  162.   OPENW #1,0,0,640,256,0,1024,1
  163.   TITLEW #1,"                               Planetarium"
  164.   ~ActivateWindow(WINDOW(1))
  165.   cont&=0
  166.   @setcol1
  167.   @about
  168.   @initmenu1
  169.   WHILE cont&=0
  170.     ON MENU GOSUB checkmenu
  171.     SLEEP
  172.   WEND
  173. RETURN
  174. '  -----------------------------------
  175. PROCEDURE about
  176.   CLS
  177.   LOCATE 1,3
  178.   PCOLOR 4,0
  179.   PRINT "This program, originally written for C64 by H.Hinkelmann, shows a view of the"
  180.   PRINT
  181.   PRINT "whole sky (a celestial chart) for any date and time and any place on earth."
  182.   PRINT
  183.   PRINT "Default time is system time, read by the program from time$ and date$,"
  184.   PRINT
  185.   PRINT "default place is W"+CHR$(220)+"NNENBERG (where I live)."
  186.   PRINT
  187.   PRINT "Date, time and place may be altered by selecting the appropriate functions"
  188.   PRINT
  189.   PRINT "from the pulldown menu. Pointing at stars and clicking the left mousebutton"
  190.   PRINT
  191.   PRINT "will cause flashing of all stars belonging to the constellation. The name of"
  192.   PRINT
  193.   PRINT "the star you pointed at and the name of its constellation (german and latin)"
  194.   PRINT
  195.   PRINT "will be shown. Choosing 'Look for name' from the menu will let you enter the"
  196.   PRINT
  197.   PRINT "name of a star or constellation and show their positions as explained before."
  198.   PRINT
  199.   PRINT "The other functions are self-explicable (I hope)."
  200.   PRINT
  201.   PRINT "ENJOY !!"
  202. RETURN
  203. '  -----------------------------------
  204. PROCEDURE initmenu1
  205.   RESTORE men1
  206.   i%=-1
  207.   REPEAT
  208.     INC i%
  209.     READ men$(i%)
  210.   UNTIL men$(i%)="ENDE"
  211.   men$(i%)=""
  212.   men$(i%+1)=""
  213.   MENU men$()
  214.   FOR i%=4 TO 7
  215.     MENU (i%),16+192
  216.   NEXT i%
  217.   MENU (27+resolution&),16+64+256            ! set hook
  218.   MENU (22+mode&),16+64+256
  219.   MENU (12+presetloc&),16+64+256
  220.   @keys
  221. RETURN
  222. '  -----------------------------------
  223. PROCEDURE keys
  224.   MENU KEY 1,ASC("c")
  225.   MENU KEY 2,ASC("q")
  226.   MENU KEY 10,ASC("l")
  227.   MENU KEY 11,ASC("d")
  228.   MENU KEY 23,ASC("s")
  229.   MENU KEY 24,ASC("p")
  230.   MENU KEY 25,ASC("t")
  231.   MENU KEY 28,ASC("1")
  232.   MENU KEY 29,ASC("2")
  233.   MENU KEY 32,ASC("n")
  234.   MENU KEY 35,ASC("h")
  235.   MENU KEY 36,ASC("i")
  236. RETURN
  237. '  -----------------------------------
  238. PROCEDURE checkmenu
  239.   SELECT MENU(0)
  240.   CASE 1
  241.     cont&=mode&
  242.   CASE 2                     ! closeprogram
  243.     cont&=1
  244.     end&=1
  245.   CASE 10,11
  246.     ON (MENU(0)-9) GOSUB setloc,settime
  247.     cont&=mode&
  248.   CASE 13 TO 19              ! pre-set locations
  249.     presetloc&=MENU(0)-12
  250.     FOR i&=13 TO 20
  251.       MENU (i&),16+64
  252.     NEXT i&
  253.     MENU (12+presetloc&),16+64+256
  254.     @presetloc
  255.     @show_loc
  256.     cont&=mode&
  257.   CASE 20
  258.     @setstime
  259.     cont&=mode&
  260.   CASE 23,24                 ! chart or planetarium
  261.     EVERY STOP
  262.     sim!=FALSE
  263.     mode&=MENU(0)-22
  264.     cont&=mode&
  265.     MENU 23,16+64
  266.     MENU 24,16+64
  267.     MENU MENU(0),16+64+256
  268.     IF mode&=2
  269.       cont&=mode&
  270.       FOR i&=10 TO 20
  271.         MENU i&,16+16        ! not to be chosen in planetarium-mode
  272.       NEXT i&
  273.     ENDIF
  274.   CASE 25                    ! toggle telescope-mode on/off
  275.     IF tele!=TRUE THEN
  276.       tele!=FALSE
  277.       MENU 25,16+64
  278.     ELSE
  279.       tele!=TRUE
  280.       MENU 25,16+64+256
  281.     ENDIF
  282.   CASE 28,29                 ! MedRes or HiRes
  283.     cont&=mode&
  284.     sim!=FALSE
  285.     resolution&=MENU(0)-27
  286.     FOR i&=28 TO 29
  287.       MENU i&,16+64
  288.     NEXT i&
  289.     MENU MENU(0),16+64+256
  290.   CASE 32                    ! look for star/constellation
  291.     IF mode&=2               ! interrupt planetarium-mode
  292.       EVERY STOP
  293.       @get_name
  294.       EVERY  CONT
  295.     ELSE
  296.       @get_name
  297.     ENDIF
  298.   CASE 35                    ! hardcopy
  299.     @print
  300.   CASE 36
  301.     IF in_chart!=TRUE THEN
  302.       in_chart!=FALSE
  303.       MENU 36,16+64
  304.     ELSE
  305.       in_chart!=TRUE
  306.       MENU 36,16+64+256
  307.     ENDIF
  308.   ENDSELECT
  309. RETURN
  310. '  -----------------------------------
  311. PROCEDURE setloc
  312.   SETWPEN 7,6
  313.   OPENW #2,110,verti&/2-60,420,120,0,0,1
  314.   TITLEW #2," Please enter coordinates :"
  315.   ~ActivateWindow(WINDOW(2))
  316.   CLS
  317.   LOCATE 1,1
  318.   PRINT "    Accepted are:"
  319.   PRINT "    Latitude    90 (north) to  -90 (south)"
  320.   PRINT "    Longitude  180 (west)  to -180 (east)"
  321.   PRINT " ---------------------------------------------"
  322.   latitude$=STR$(latitude)
  323.   longitude$=STR$(longitude)
  324.   latitude=500
  325.   longitude=500
  326.   loc$=""
  327.   WHILE ABS(latitude)>90
  328.     LOCATE 1,6
  329.     PRINT "    Latitude         ";
  330.     FORM INPUT 5 AS latitude$
  331.     latitude=VAL(latitude$)
  332.   WEND
  333.   WHILE ABS(longitude)>180
  334.     LOCATE 1,8
  335.     PRINT "    Longitude        ";
  336.     FORM INPUT 6 AS longitude$
  337.     longitude=VAL(longitude$)
  338.   WEND
  339.   LOCATE 1,10
  340.   INPUT "    Name of location ",loc$
  341.   CLOSEW #2
  342.   COLOR 0,6
  343.   SETWPEN 0,7
  344.   FOR i&=13 TO 20
  345.     MENU (i&),16+64
  346.   NEXT i&
  347.   presetloc&=0
  348. RETURN
  349. '  -----------------------------------
  350. PROCEDURE settime
  351.   @systemtime
  352.   wtime=VAL(LEFT$(localtime$,2))+VAL(MID$(localtime$,4,2))/100-1
  353.   IF wtime<0 THEN
  354.     wtime=wtime+24
  355.   ENDIF
  356.   OPENW #2,110,verti&/2-60,420,120,0,0,1
  357.   TITLEW #2," Set time of observation :"
  358.   ~ActivateWindow(WINDOW(2))
  359.   CLS
  360.   LOCATE 1,1
  361.   PRINT "           Present dates:"
  362.   PRINT " ---------------------------------------------"
  363.   PRINT "          Date :   ";DATE$
  364.   PRINT "    Systemtime :   ";localtime$
  365.   PRINT "Universal time :   ";wtime
  366.   PRINT " ---------------------------------------------"
  367.   year&=0
  368.   month&=0
  369.   day&=0
  370.   WHILE year&<=0 OR year&>3000
  371.     LOCATE 3,7
  372.     PRINT "Year   ";
  373.     FORM INPUT 4 AS year$
  374.     year&=VAL(year$)
  375.   WEND
  376.   WHILE month&<=0 OR month&>12
  377.     LOCATE 16,7
  378.     PRINT "Month  ";
  379.     FORM INPUT 2 AS month$
  380.     month&=VAL(month$)
  381.   WEND
  382.   IF (month&<8 AND month& MOD 2<>0) OR (month&>7 AND month& MOD 2=0) THEN
  383.     WHILE day&<=0 OR day&>31
  384.       LOCATE 30,7
  385.       PRINT "Day   ";
  386.       FORM INPUT 2 AS day$
  387.       day&=VAL(day$)
  388.     WEND
  389.   ENDIF
  390.   IF (month&<8 AND month& MOD 2=0) OR (month&>7 AND month& MOD 2<>0) THEN
  391.     WHILE day&<=0 OR day&>30
  392.       LOCATE 30,7
  393.       PRINT "Day   ";
  394.       FORM INPUT 2 AS day$
  395.       day&=VAL(day$)
  396.     WEND
  397.   ENDIF
  398.   IF month&=2 AND year& MOD 4<>0 THEN
  399.     WHILE day&<=0 OR day&>28
  400.       LOCATE 30,7
  401.       PRINT "Day   ";
  402.       FORM INPUT 2 AS day$
  403.       day&=VAL(day$)
  404.     WEND
  405.   ENDIF
  406.   IF month&=2 AND year& MOD 4=0 AND year& MOD 400<>0 THEN
  407.     WHILE day&<=0 OR day&>29
  408.       LOCATE 30,7
  409.       PRINT "Day   ";
  410.       FORM INPUT 2 AS day$
  411.       day&=VAL(day$)
  412.     WEND
  413.   ENDIF
  414.   IF month&=2 AND year& MOD 4=0 AND year& MOD 400=0 THEN
  415.     WHILE day&<=0 OR day&>28
  416.       LOCATE 30,7
  417.       PRINT "Day   ";
  418.       FORM INPUT 2 AS day$
  419.       day&=VAL(day$)
  420.     WEND
  421.   ENDIF
  422.   PRINT "---------------------------------------------"
  423.   wtime$=STR$(wtime)
  424.   wtime=-1
  425.   WHILE wtime<0 OR wtime>23.59 OR FRAC(wtime)>=0.6
  426.     PRINT AT(2,9);" Plase enter universal time (hh.mm):";
  427.     LOCATE 20,11
  428.     FORM INPUT 5 AS wtime$
  429.     wtime=VAL(wtime$)
  430.   WEND
  431.   datum$=RIGHT$("0"+STR$(day&),2)+"."+RIGHT$("0"+STR$(month&),2)+"."+STR$(year&)
  432.   s_time!=FALSE
  433.   CLOSEW #2
  434. RETURN
  435. '  -----------------------------------
  436. PROCEDURE wuennenberg
  437.   loc$="W"+CHR$(252)+"nnenberg"
  438.   latitude=52
  439.   longitude=-8.5
  440. RETURN
  441. '  -----------------------------------
  442. PROCEDURE berlin
  443.   loc$="Berlin"
  444.   latitude=51.6
  445.   longitude=-14
  446. RETURN
  447. '  -----------------------------------
  448. PROCEDURE moskow
  449.   loc$="Moskow"
  450.   latitude=55.5
  451.   longitude=-37.5
  452. RETURN
  453. '  -----------------------------------
  454. PROCEDURE new_york
  455.   loc$="New York"
  456.   latitude=40.6
  457.   longitude=-74
  458. RETURN
  459. '  -----------------------------------
  460. PROCEDURE arctic
  461.   loc$="Arctic Pole"
  462.   latitude=90
  463.   longitude=0
  464. RETURN
  465. '  -----------------------------------
  466. PROCEDURE antarctic
  467.   loc$="Antarctic Pole"
  468.   latitude=-90
  469.   longitude=0
  470. RETURN
  471. '  -----------------------------------
  472. PROCEDURE quito
  473.   loc$="Quito (equator)"
  474.   latitude=0.5
  475.   longitude=78
  476. RETURN
  477. '  -----------------------------------
  478. PROCEDURE show_loc
  479.   w_width&=28*8+8*LEN(loc$)+4
  480.   OPENW #3,hori&/2-w_width&/2,verti&/2-15,w_width&,30,0,0,1
  481.   TITLEW #3,"         Location "
  482.   CLS
  483.   PRINT
  484.   PRINT " .. setting parameters for "+loc$;
  485.   DELAY 1
  486.   CLOSEW #3
  487. RETURN
  488. '  -----------------------------------
  489. PROCEDURE setstime
  490.   s_time!=TRUE
  491.   OPENW #3,hori&/2-120,verti&/2-15,240,30,0,0,1
  492.   TITLEW #3,"            Time "
  493.   CLS
  494.   PRINT
  495.   PRINT "   ...... setting systemtime"
  496.   DELAY 1
  497.   CLOSEW #3
  498. RETURN
  499. '  ===================================
  500. PROCEDURE starchart
  501.   cont&=0
  502.   WHILE cont&=0
  503.     @buildscreen
  504.     @set_stars
  505.     sim!=TRUE
  506.     @initmenu2
  507.     DEFMOUSE 3
  508.     SETCOLOR 17,&HF00
  509.     @functs
  510.   WEND
  511. RETURN
  512. '  -----------------------------------
  513. PROCEDURE buildscreen
  514.   @adapt
  515.   IF ABS(latitude)=90
  516.     MUL latitude,0.99999999
  517.   ENDIF
  518.   sb=SIN(RAD(latitude))
  519.   cb=COS(RAD(latitude))
  520.   IF s_time!=TRUE THEN
  521.     @systemtime
  522.     IF MID$(localtime$,2,1)=":" THEN
  523.       wtime=VAL(LEFT$(localtime$,2))+VAL(MID$(localtime$,3,2))/100-1
  524.     ELSE
  525.       wtime=VAL(LEFT$(localtime$,2))+VAL(MID$(localtime$,4,2))/100-1
  526.     ENDIF
  527.     IF wtime<0 THEN
  528.       wtime=wtime+24
  529.     ENDIF
  530.   ENDIF
  531.   IF mode&=1 THEN
  532.     @timefunction
  533.   ENDIF
  534.   IF loc$<>"" AND LEFT$(loc$,3)<>"for" THEN
  535.     loc$="for "+loc$
  536.   ENDIF
  537.   IF sim!=FALSE THEN
  538.     CLOSES 1
  539.     SETWPEN 0,7
  540.     OPENS 1,0,0,hori&,verti&+15,3,modus%
  541.     OPENW #0,0,0,hori&,verti&+14,8+16+1024,512+1024,1
  542.     @setcol2
  543.     CLS
  544.     COLOR 7
  545.     ELLIPSE hori&/2,verti&/2+yoff&/2,radius&*extend&,radius&
  546.     COLOR 1
  547.     TEXT 40,55*yfak,"Moon"
  548.   ENDIF
  549.   TITLEW #0,"Celestial chart "+loc$
  550.   ~ActivateWindow(WINDOW(0))
  551.   BOUNDARY 0
  552.   COLOR 0
  553.   PELLIPSE hori&/2,verti&/2+yoff&/2,radius&*extend&-1,radius&-1
  554.   PCOLOR 6
  555.   IF latitude<0 THEN
  556.     hu=verti&
  557.   ELSE
  558.     hu=0
  559.   ENDIF
  560.   COLOR 6
  561.   ELLIPSE hori&/2,hu+latitude/9*10*yfak,radius&/50*extend&,radius&/50
  562.   PRINT AT(xfak&,0);datum$
  563.   PRINT AT(xfak&,3);"OZ "+oz$
  564.   PRINT AT(xfak&,4);"WZ "+wz$
  565.   IF longitude<0 THEN
  566.     o$=SPACE$(xfak&-1)+"E"
  567.   ELSE
  568.     o$=SPACE$(xfak&-1)+"W"
  569.   ENDIF
  570.   l$=RIGHT$(SPACE$(4)+STR$(CINT(ABS(longitude))),3)
  571.   LOCATE 31*xfak&-3,1
  572.   PRINT "Longitude :";l$;o$
  573.   IF latitude<0 THEN
  574.     o$=SPACE$(xfak&-1)+"S"
  575.     COLOR 1
  576.   ELSE
  577.     o$=SPACE$(xfak&-1)+"N"
  578.     COLOR 1
  579.   ENDIF
  580.   COLOR 6
  581.   TEXT hori&/2-radius&*extend&-10,verti&/2-4,"E"
  582.   TEXT hori&/2+radius&*extend&+2,verti&/2-4,"W"
  583.   l$=RIGHT$(SPACE$(4)+STR$(CINT(ABS(latitude))),3)
  584.   LOCATE 31*xfak&-3,2
  585.   PRINT "Latitude  :";l$;o$
  586.   COLOR 1
  587. RETURN
  588. '  -----------------------------------
  589. PROCEDURE adapt
  590.   SELECT resolution&
  591.   CASE 1
  592.     modus%=32768
  593.     hori&=640
  594.     verti&=248
  595.     extend&=2
  596.   CASE 2
  597.     modus%=32772
  598.     hori&=640
  599.     verti&=502
  600.     extend&=1
  601.   ENDSELECT
  602.   xfak&=hori&/320
  603.   yfak=verti&/200
  604.   yoff&=0
  605.   radius&=(verti&)/2
  606.   ' -------------------
  607. RETURN
  608. '  -----------------------------------
  609. PROCEDURE set_stars
  610.   t%=TIMER
  611.   n1$=""
  612.   @earthsunmoon
  613.   @planets
  614.   @stars
  615.   t%=TIMER-t%
  616.   PRINT AT(65,28*yfak);USING "#.##  sec",t%/200;
  617. RETURN
  618. '  -----------------------------------
  619. PROCEDURE earthsunmoon
  620.   be=FN mo(tg*0.985609121+99.18)
  621.   ex=FN mo(be+SINQ(be-102.2)*1.845)
  622.   ea=1+SINQ(ex-192.2)*0.0167
  623.   ' Sun:
  624.   ls=FN mo(ex+180)
  625.   ' Moon:
  626.   lm=FN mo(tg*13.1763976+51.23)
  627.   pm=FN mo(tg*0.111399014+208.9)
  628.   km=FN mo(372.1-tg*0.052953643)
  629.   am=lm-pm
  630.   km=km-SINQ(acs)*0.16
  631.   ms=(lm-ls)*2-am
  632.   am=am+SINQ(ms)*1.2738888889-SINQ(acs)*(0.18638888889+0.36)
  633.   lm=lm+SINQ(ms)*1.2738888889-SINQ(acs)*0.18638888889+SINQ(am)*6.28833333
  634.   m1=lm-ls
  635.   lm=lm+SINQ(m1*2)*0.65833333333
  636.   m2=lm-km
  637.   lm=lm-SINQ(m2*2)*0.12
  638.   bm=SINQ(m2)*5.14539
  639.   m3=(lm-ls)*2-m2
  640.   bm=bm+SINQ(m3)*0.15
  641.   @rekdek(0,ls)
  642.   @plot(0,2,re,de)
  643.   moon=FN mo(lm-ls)
  644.   @phase(moon)
  645.   IF x&>0
  646.     COLOR 2
  647.     PELLIPSE x&,y&,radius&/60*extend&,radius&/60
  648.     COLOR 4
  649.     ELLIPSE x&,y&,radius&/60*extend&,radius&/60
  650.   ENDIF
  651.   @rekdek(bm,lm)
  652.   COLOR 4
  653.   @plot(0,4,re,de)
  654.   IF x&>0
  655.     PELLIPSE x&,y&,radius&/60*extend&,radius&/60
  656.   ENDIF
  657.   PUT 50-19,32*yfak-(resolution&-1),moon$(resolution&)
  658.   COLOR 0
  659.   PELLIPSE x_dark&,39*yfak+(resolution&-1),(radius&/15)*extend&+1,radius&/15+1
  660. RETURN
  661. '  -----------------------------------
  662. PROCEDURE stars
  663.   FOR s&=1 TO i1&
  664.     IF lk(s&)<1 THEN
  665.       col&=4
  666.     ELSE
  667.       col&=lk(s&)+3
  668.     ENDIF
  669.     @plot(lk(s&),col&,re(s&),de(s&))
  670.     fpos&(s&,0)=x&        ! screepositions of
  671.     fpos&(s&,1)=y&        ! stars
  672.   NEXT s&
  673. RETURN
  674. '  -----------------------------------
  675. PROCEDURE planets
  676.   FOR pl&=0 TO 5
  677.     ml=FN mo(tb(pl&)*tg+ep(pl&))
  678.     wl=ml+SINQ(ml-ph(pl&))*mp(pl&)
  679.     sp=ae(pl&)+SINQ(wl-ph(pl&)-90)*e(pl&)*ae(pl&)
  680.     ws=FN mo(360+ex-wl)
  681.     si=SINQ(ws)
  682.     IF si=0
  683.       si=1.0E-10
  684.     ENDIF
  685.     fl=ea/sp-COSQ(ws)
  686.     we=DEG(ATN(si/fl))
  687.     al=FN mo(ex+we-180*(fl>=0))
  688.     wt=SINQ(DEG(((wl-kn(pl&))*PI)*i(pl&)))
  689.     ab=DEG(ATN(TAN(RAD(wt))*ABS(SINQ(we)/si)))
  690.     @rekdek(ab,al)
  691.     @plot(-1,1,re,de)
  692.     plpos&(pl&,0)=x&       ! screenpositions of
  693.     plpos&(pl&,1)=y&       ! planets
  694.   NEXT pl&
  695. RETURN
  696. '  -----------------------------------
  697. PROCEDURE rekdek(ab,al)
  698.   sn=SINQ(ab)
  699.   cs=COSQ(ab)
  700.   sl=SINQ(al)
  701.   cl=COSQ(al)
  702.   de=DEG(ASIN(ec*sn+es*cs*sl))
  703.   re=DEG(2*ATN((ec*cs*sl-es*sn)/(COSQ(de)+cs*cl)))
  704.   re=FN mo(re)
  705. RETURN
  706. '  -----------------------------------
  707. PROCEDURE plot(lk,color&,re,de)
  708.   ' ------ Stundenwinkel ------
  709.   sw=FN mo(ar-re-longitude)
  710.   ' ------ transform coordinates ------
  711.   h=ASIN(sb*SINQ(de)+cb*COSQ(de)*COSQ(sw))
  712.   IF h<0 THEN
  713.     x&=0
  714.     y&=0
  715.   ELSE
  716.     a=(SINQ(de)-sb*SIN(h))/(cb*COS(h))
  717.     IF ABS(a)>=1 THEN
  718.       a=a*0.9998
  719.     ENDIF
  720.     a=ACOS(a)
  721.     IF sw<180 THEN
  722.       a=-a
  723.     ENDIF
  724.     ' ------ Gradmaß ------
  725.     r=99-h*198/PI
  726.     w=-a-PI/2
  727.     x&=(COS(w)*r*xfak&*0.6125*xfak&+hori&/2-0.5)
  728.     y&=(SIN(w)*r*yfak+verti&/2-0.5)
  729.     ' ---------------------
  730.     COLOR color&
  731.     IF lk>0 THEN
  732.       PLOT x&,y&
  733.     ELSE
  734.       PELLIPSE x&,y&,1*extend&,1
  735.     ENDIF
  736.   ENDIF
  737. RETURN
  738. '  -----------------------------------
  739. PROCEDURE print
  740.   SETCOLOR 0,15,15,15       ! white
  741.   SETCOLOR 4,0,0,0          ! black
  742.   SETCOLOR 5,0,0,0          ! black
  743.   SETCOLOR 6,0,0,0          ! black
  744.   SETCOLOR 7,0,0,0          ! black
  745.   HARDCOPY
  746.   @setcol2
  747. RETURN
  748. '  ===================================
  749. PROCEDURE timefunction
  750.   day&=VAL(LEFT$(datum$,2))
  751.   month&=VAL(MID$(datum$,4,2))
  752.   year&=VAL(MID$(datum$,7))
  753.   @time
  754. RETURN
  755. '  -----------------------------------
  756. PROCEDURE time
  757.   datum$=RIGHT$("0"+STR$(day&),2)+"."+RIGHT$("0"+STR$(month&),2)+"."+STR$(year&)
  758.   wz$=STR$(wtime,5,2)
  759.   wz$=" "+wz$
  760.   zt=INT(wtime)+(FRAC(wtime)/0.6)
  761.   lo=INT(longitude/15)*15
  762.   oz=FN mo(zt*15-lo)/15
  763.   oz$=" "+STR$(INT(oz))+RIGHT$(wz$,3)
  764.   IF LEN(oz$)<6
  765.     oz$=" "+oz$
  766.   ENDIF
  767.   ii=month&<3
  768.   k=day&+INT((153*month&-11*ii-162)/5)+INT((1461*year&+ii)/4)+(year&>=0)*366
  769.   IF k>577736 THEN
  770.     k=k-INT((INT((year&+ii)/100)*3-5)/4)
  771.   ENDIF
  772.   ta=k-693596               ! days since 1.1.1900
  773.   tg=k-711858+zt/24
  774.   ii=ta/36525
  775.   e=23.452294-ii*0.013125-ii*ii*1.639E-06+ii*ii*ii*5.028E-07
  776.   es=SINQ(e)
  777.   ec=COSQ(e)
  778.   ' aries:
  779.   ar=zt*360.985647/24+FRAC(ta/1461)*1440.02509
  780.   ar=ar+INT(ta/1461)*0.307572+99.2018973
  781.   ar=FN mo(ar)
  782. RETURN
  783. '  -----------------------------------
  784. PROCEDURE phase(phase)
  785.   IF phase<=180 THEN                                 ! increasing moon
  786.     x_dark&=50-phase/180*radius&/15*extend&*2
  787.   ELSE                                               ! wanting moon
  788.     x_dark&=50+(360-phase)/180*radius&/15*extend&*2
  789.   ENDIF
  790. RETURN
  791. '  ===================================
  792. '  -----------------------------------
  793. PROCEDURE initmenu2
  794.   MENU men$()
  795.   FOR i%=4 TO 7
  796.     MENU (i%),16+192
  797.   NEXT i%
  798.   MENU 24,16+64                    ! make menuitems available
  799.   MENU 25,16+64
  800.   MENU 32,16+64
  801.   MENU 35,16+64
  802.   MENU 36,16+64
  803.   MENU 27+resolution&,16+64+256    ! set hook
  804.   MENU 22+mode&,16+64+256
  805.   IF tele!=TRUE
  806.     MENU 25,16+64+256
  807.   ENDIF
  808.   IF presetloc&<>0
  809.     MENU (12+presetloc&),16+64+256
  810.   ENDIF
  811.   IF in_chart!=TRUE
  812.     MENU 36,16+64+256
  813.   ENDIF
  814.   @keys
  815. RETURN
  816. '  -----------------------------------
  817. PROCEDURE functs
  818.   done!=FALSE
  819.   WHILE cont&=0
  820.     ON MENU GOSUB checkmenu
  821.     ON MENU BUTTON GOSUB checkpos
  822.     SLEEP
  823.   WEND
  824. RETURN
  825. '  -----------------------------------
  826. PROCEDURE get_name
  827.   SETWPEN 7,6
  828.   OPENW #2,110,verti&/2-60,420,50,0,0,1
  829.   TITLEW #2,"Look for star or constellation"
  830.   ~ActivateWindow(WINDOW(2))
  831.   PRINT " Please enter name or part of";
  832.   INPUT " name :";star$
  833.   CLOSEW #2
  834.   SETWPEN 0,7
  835.   ~ActivateWindow(WINDOW(0))
  836.   @searchname
  837.   IF found!=FALSE THEN
  838.     @mistake(star$+" unknown !")
  839.   ELSE
  840.     @found
  841.   ENDIF
  842. RETURN
  843. '  -----------------------------------
  844. PROCEDURE searchname
  845.   found!=FALSE
  846.   FOR p&=0 TO 5
  847.     IF INSTR(plan$(p&),star$)<>0 THEN
  848.       fall&=0
  849.       show&=p&
  850.       found!=TRUE
  851.     ENDIF
  852.     EXIT IF found!=TRUE
  853.   NEXT p&
  854.   IF found!=FALSE THEN
  855.     FOR s&=1 TO i1&
  856.       IF INSTR(fstern$(s&),star$)<>0
  857.         show&=s&
  858.         fall&=1
  859.         found!=TRUE
  860.       ENDIF
  861.       EXIT IF found!=TRUE
  862.     NEXT s&
  863.   ENDIF
  864.   IF found!=FALSE THEN
  865.     FOR sb&=0 TO i3&
  866.       IF INSTR(z$(sb&,0),star$)<>0 OR INSTR(z$(sb&,1),star$)<>0
  867.         show&=sb&
  868.         fall&=2
  869.         found!=TRUE
  870.       ENDIF
  871.       EXIT IF found!=TRUE
  872.     NEXT sb&
  873.   ENDIF
  874. RETURN
  875. '  -----------------------------------
  876. PROCEDURE found
  877.   x&=0
  878.   y&=0
  879.   SELECT fall&
  880.   CASE 0                  ! planet found
  881.     x&=plpos&(show&,0)
  882.     y&=plpos&(show&,1)
  883.     IF x&=0 AND y&=0
  884.       @mistake(plan$(show&)+" not visible !")
  885.     ELSE
  886.       @display(plan$(show&),"")
  887.       COLOR 3
  888.       PELLIPSE x&,y&,1*extend&,1
  889.       @blink(0,plan$(show&),"")
  890.       COLOR 1
  891.       PELLIPSE x&,y&,1*extend&,1
  892.     ENDIF
  893.   CASE 1                  ! star found
  894.     x&=fpos&(show&,0)
  895.     y&=fpos&(show&,1)
  896.     IF x&=0 AND y&=0
  897.       @mistake(fstern$(show&)+" not visible !")
  898.     ELSE
  899.       @display(fstern$(show&),z$(const&(show&),0)+"  "+z$(const&(show&),1))
  900.       COLOR 1
  901.       ELLIPSE x&,y&,2*extend&,2
  902.       @constellation("blin")
  903.       @blink(0,fstern$(show&),z$(const&(show&),0)+"  "+z$(const&(show&),1))
  904.       COLOR 0
  905.       ELLIPSE x&,y&,2*extend&,2
  906.       @constellation("rest")
  907.     ENDIF
  908.   CASE 2                 ! constellation found
  909.     from&=z&(show&,1)
  910.     to&=z&(show&,1)+z&(show&,0)
  911.     FOR i&=from& TO to&
  912.       IF fpos&(i&,0)<>0 AND fpos&(i&,1)<>0 THEN
  913.         x&=fpos&(i&,0)
  914.         y&=fpos&(i&,1)
  915.         show&=i&
  916.       ENDIF
  917.       EXIT IF fpos&(i&,0)<>0 AND fpos&(i&,1)<>0
  918.     NEXT i&
  919.     IF x&=0 AND y&=0
  920.       @mistake(z$(show&,1)+" not visible !")
  921.     ELSE
  922.       @display(fstern$(show&),z$(const&(show&),0)+"  "+z$(const&(show&),1))
  923.       COLOR 1
  924.       ELLIPSE x&,y&,2*extend&,2
  925.       @constellation("blin")
  926.       @blink(0,fstern$(show&),z$(const&(show&),0)+"  "+z$(const&(show&),1))
  927.       COLOR 0
  928.       ELLIPSE x&,y&,2*extend&,2
  929.       @constellation("rest")
  930.     ENDIF
  931.   ENDSELECT
  932. RETURN
  933. '  -----------------------------------
  934. PROCEDURE checkpos
  935.   IF done!=FALSE AND MENU(5)>hori&/2-radius&*extend& AND MENU(5)<hori&/2+radius&*extend&
  936.     mausx&=MENU(5)
  937.     mausy&=MENU(6)-10
  938.     @searchstar
  939.     IF fall&=0
  940.       x&=plpos&(show&,0)
  941.       y&=plpos&(show&,1)
  942.       @display(plan$(show&),"")
  943.       GRAPHMODE 1
  944.       COLOR 3
  945.       PELLIPSE x&,y&,1*extend&,1
  946.       @blink(1,plan$(show&),"")
  947.       COLOR 1
  948.       PELLIPSE x&,y&,1*extend&,1
  949.       GRAPHMODE 1
  950.     ELSE
  951.       x&=fpos&(show&,0)
  952.       y&=fpos&(show&,1)
  953.       @display(fstern$(show&),z$(const&(show&),0)+"  "+z$(const&(show&),1))
  954.       COLOR 1
  955.       ELLIPSE x&,y&,2*extend&,2
  956.       @constellation("blin")
  957.       @blink(1,fstern$(show&),z$(const&(show&),0)+"  "+z$(const&(show&),1))
  958.       COLOR 0
  959.       ELLIPSE x&,y&,2*extend&,2
  960.       @constellation("rest")
  961.     ENDIF
  962.   ENDIF
  963.   done!=done! XOR TRUE
  964. RETURN
  965. '  -----------------------------------
  966. PROCEDURE searchstar
  967.   fall&=0
  968.   min%=2000000
  969.   FOR p&=0 TO 5
  970.     f1%=plpos&(p&,0)-mausx&
  971.     f2%=plpos&(p&,1)-mausy&
  972.     xx%=f1%*f1%+f2%*f2%
  973.     IF xx%<min% THEN
  974.       min%=xx%
  975.       show&=p&
  976.     ENDIF
  977.   NEXT p&
  978.   FOR s&=1 TO i1&
  979.     f1%=fpos&(s&,0)-mausx&
  980.     f2%=fpos&(s&,1)-mausy&
  981.     xx%=f1%*f1%+f2%*f2%
  982.     IF xx%<min% THEN
  983.       min%=xx%
  984.       show&=s&
  985.       fall&=1
  986.     ENDIF
  987.   NEXT s&
  988. RETURN
  989. '  ----------------------------------
  990. PROCEDURE display(n$,n1$)
  991.   IF in_chart!=TRUE
  992.     GRAPHMODE 2
  993.     TEXT x&-8*LEN(n$)/2,y&+10,n$
  994.     GRAPHMODE 1
  995.   ENDIF
  996.   LSET format$=n$
  997.   PRINT AT(xfak&,60/extend&);format$;
  998.   LSET format1$=n1$
  999.   PRINT AT(xfak&,60/extend&+1);format1$;
  1000. RETURN
  1001. '  -----------------------------------
  1002. PROCEDURE constellation(do$)
  1003.   GRAPHMODE 1
  1004.   from&=z&(const&(show&),1)
  1005.   to&=z&(const&(show&),1)+z&(const&(show&),0)
  1006.   SELECT do$
  1007.   CASE "blin"
  1008.     COLOR 3
  1009.     FOR i&=from& TO to&
  1010.       IF fpos&(i&,0)<>0
  1011.         PLOT fpos&(i&,0),fpos&(i&,1)
  1012.       ENDIF
  1013.     NEXT i&
  1014.   CASE "rest"
  1015.     FOR i&=from& TO to&
  1016.       IF fpos&(i&,0)<>0
  1017.         IF lk(i&)<1 THEN
  1018.           col&=4
  1019.         ELSE
  1020.           col&=lk(i&)+3
  1021.         ENDIF
  1022.         COLOR col&
  1023.         PLOT fpos&(i&,0),fpos&(i&,1)
  1024.       ENDIF
  1025.     NEXT i&
  1026.   ENDSELECT
  1027. RETURN
  1028. '  -----------------------------------
  1029. PROCEDURE blink(bed|,n$,n1$)
  1030.   alle%=0
  1031.   aha!=FALSE
  1032.   DO
  1033.     FOR i=15 TO 0 STEP -0.1
  1034.       SETCOLOR 3,i,i,0
  1035.     NEXT i
  1036.     FOR i=0 TO 15 STEP 0.1
  1037.       SETCOLOR 3,i,i,0
  1038.     NEXT i
  1039.   LOOP WHILE MOUSEK=bed|
  1040.   EVERY STOP
  1041.   IF tele!=TRUE THEN                                  ! look for picture
  1042.     i&=0
  1043.     REPEAT
  1044.       INC i&
  1045.       IF INSTR(n1$,avail$(i&)) OR avail$(i&)=n$
  1046.         aha!=TRUE
  1047.         DISPLAY OFF
  1048.         @load_acbm(pfad$+avail$(i&)+".pic",99)        ! load graphic to screen
  1049.         DISPLAY ON
  1050.         REPEAT
  1051.         UNTIL MOUSEK
  1052.         CLOSES 7
  1053.         FRONTS 1
  1054.       ENDIF
  1055.     UNTIL aha!=TRUE OR i&>=avail&
  1056.   ENDIF
  1057.   IF mode&=2
  1058.     EVERY  CONT
  1059.   ENDIF
  1060. RETURN
  1061. '  -----------------------------------
  1062. PROCEDURE mistake(mist$)
  1063.   w_x&=hori&/2-4*LEN(mist$)-2
  1064.   w_y&=verti&/2-25
  1065.   SETWPEN 0,3
  1066.   OPENW #2,w_x&,w_y&,8*LEN(mist$)+8,50,0,0,1
  1067.   TITLEW #2,"   ERROR !!"
  1068.   SOUND 1660,20,255
  1069.   PRINT mist$
  1070.   DELAY 2
  1071.   CLOSEW #2
  1072.   SETWPEN 0,7
  1073. RETURN
  1074. '  ===================================
  1075. PROCEDURE planetarium
  1076.   loc$=loc$+"          *** Planetarium ***"
  1077.   s_time!=FALSE
  1078.   @setplanparam
  1079.   $I+
  1080.   EVERY delay&*200+t% GOSUB animate
  1081.   @animate
  1082.   DO
  1083.     $U+
  1084.     SLEEP
  1085.     EXIT IF cont&=1
  1086.   LOOP
  1087.   EVERY STOP
  1088.   $U-
  1089.   $I-
  1090.   end&=0
  1091.   MENU 23,16+64+256
  1092.   MENU 24,16+64
  1093.   '  sim!=FALSE
  1094.   mode&=1
  1095.   loc$=MID$(loc$,5,LEN(loc$)-29)
  1096. RETURN
  1097. '  -----------------------------------
  1098. PROCEDURE setplanparam
  1099.   SETWPEN 7,6
  1100.   OPENW #2,190,verti&/2-20,242,40,0,0,1
  1101.   TITLEW #2,"Parameters for simulation"
  1102.   ~ActivateWindow(WINDOW(2))
  1103.   PRINT " Interval (hours)  ";
  1104.   FORM INPUT 4 AS interval$
  1105.   interval&=VAL(interval$)
  1106.   PRINT " Delay   (seconds) ";
  1107.   FORM INPUT 3 AS delay$
  1108.   delay&=VAL(delay$)
  1109.   CLOSEW #2
  1110.   SETWPEN 0,7
  1111.   ~ActivateWindow(WINDOW(0))
  1112. RETURN
  1113. '  -----------------------------------
  1114. PROCEDURE animate
  1115.   sim!=TRUE
  1116.   ADD wtime,interval&
  1117.   IF wtime>24 THEN
  1118.     WHILE wtime>24
  1119.       wtime=wtime-24
  1120.       INC day&
  1121.     WEND
  1122.     IF (month&<8 AND month& MOD 2<>0) OR (month&>7 AND month& MOD 2=0) THEN
  1123.       IF day&>31 THEN
  1124.         INC month&
  1125.         day&=day&-31
  1126.       ENDIF
  1127.     ENDIF
  1128.     IF (month&<8 AND month& MOD 2=0) OR (month&>7 AND month& MOD 2<>0) THEN
  1129.       IF day&>30
  1130.         INC month&
  1131.         day&=day&-30
  1132.       ENDIF
  1133.     ENDIF
  1134.     IF month&=2 AND year& MOD 4<>0 THEN
  1135.       IF day&>28
  1136.         INC month&
  1137.         day&=day&-28
  1138.       ENDIF
  1139.     ENDIF
  1140.     IF month&=2 AND year& MOD 4=0 AND year& MOD 400<>0 THEN
  1141.       IF day&>29
  1142.         INC month&
  1143.         day&=day&-29
  1144.       ENDIF
  1145.     ENDIF
  1146.     IF month&=2 AND year& MOD 4=0 AND year& MOD 400=0 THEN
  1147.       IF day&>28
  1148.         INC month&
  1149.         day&=day&-28
  1150.       ENDIF
  1151.     ENDIF
  1152.     IF month&>12 THEN
  1153.       INC year&
  1154.       month&=1
  1155.     ENDIF
  1156.   ENDIF
  1157.   @time
  1158.   @buildscreen
  1159.   @set_stars
  1160. RETURN
  1161. '  ===================================
  1162. PROCEDURE closeprogram
  1163.   COLOR 1,0
  1164.   CLOSES 1
  1165. RETURN
  1166. '   ----------------------------------- End --------------------------------
  1167. '   Order of datas:
  1168. '   rektascension, deklination, name, pointer to constellation , brightness
  1169. '   ========================================================================
  1170. fstars:
  1171. DATA 37.8,89.3,Polaris,0,2.54
  1172. DATA 0269.8,86.0,UMi2,0,4.4
  1173. DATA 0252.5,82.2,UMi3,0,4.4
  1174. DATA 0246.3,75.5,UMi4,0,4.4
  1175. DATA 0238.5,78.0,UMi6,0,4.3
  1176. DATA 0230.2,71.8,Pherkad,0,3.14
  1177. DATA 0222.7,74.2,Kochab,0,2.02
  1178. DATA 0206.9,49.3,Benetnasch,1,1.87
  1179. DATA 0201.0,54.9,Mizar,1,2.17
  1180. DATA 0193.5,56.0,Alioth,1,1.78
  1181. DATA 0183.9,57.0,Megrez,1,3.44
  1182. DATA 0178.5,53.7,Phekda,1,2.54
  1183. DATA 0165.9,61.8,Dubhe,1,1.8
  1184. DATA 0165.5,56.4,Merah,1,2.44
  1185. DATA 0028.6,63.7,Achird,2,3.64
  1186. DATA 0021.5,060.2,Ksora,2,2.8
  1187. DATA 0014.2,060.7,Cas3,2,2.3
  1188. DATA 0010.1,056.5,Schedir,2,2.3
  1189. DATA 0002.3,059.2,Caph,2,2.42
  1190. DATA 0003.3,015.2,Algenib,3,2.87
  1191. DATA 0326.0,009.9,Enif,3,2.54
  1192. DATA 0346.2,015.2,Markab,3,2.57
  1193. DATA 0340.8,030.2,Homam,3,3.61
  1194. DATA 0342.5,024.6,Matar,3,3.1
  1195. DATA 0345.9,028.1,Scheat,3,2.61
  1196. DATA 0311.6,034.0,Gienah,4,2.64
  1197. DATA 0310.4,045.3,Deneb,4,1.26
  1198. DATA 0305.6,040.3,Schedir,4,2.3
  1199. DATA 0296.2,045.1,Cyg4,4,2.97
  1200. DATA 0292.7,028.0,Albireo,4,3.1
  1201. DATA 0302.8,-00.8,Aql1,5,3.37
  1202. DATA 0297.7,008.9,Altair,5,0.77
  1203. DATA 0296.6,010.6,Tarazed,5,2.8
  1204. DATA 0292.0,003.5,Deneb Okab,5,3.44
  1205. DATA 0298.8,006.3,Alshain,5,3.9
  1206. DATA 0286.6,-04.9,Aql5,5,3.5
  1207. DATA 0286.4,013.9,Aql6,5,3.02
  1208. DATA 0284.7,032.7,Sulafat,6,3.3
  1209. DATA 0283.0,037.0,Lyr2,6,3.8
  1210. DATA 0282.5,033.4,Scheliak,6,3.8
  1211. DATA 0280.2,038.8,Lyr4,6,3.8
  1212. DATA 0279.2,038.8,Wega,6,0.04
  1213. DATA 0265.6,-39.0,Sco1,7,3.2
  1214. DATA 0264.3,-43.0,Sco2,7,3.2
  1215. DATA 0263.4,-37.1,Shaula,7,1.62
  1216. DATA 0262.7,-37.3,Sco4,7,2.8
  1217. DATA 0252.5,-34.3,Sco5,7,2.36
  1218. DATA 0249.0,-28.2,Sco6,7,2.91
  1219. DATA 0247.3,-26.4,Antares,7,1.08
  1220. DATA 0241.4,-19.8,Acrab,7,2.76
  1221. DATA 0240.1,-22.6,Dschubba,7,2.54
  1222. DATA 0239.7,-26.1,Sco10,7,3.0
  1223. DATA 0228.9,033.3,Boo1,8,3.54
  1224. DATA 0225.0,041.0,Meres,8,3.63
  1225. DATA 0221.2,027.1,Izar,8,2.59
  1226. DATA 0218.0,038.3,Haris,8,3.00
  1227. DATA 0218.0,030.5,Boo5,8,3.78
  1228. DATA 0213.9,019.2,Arcturus,8,.6
  1229. DATA 0208.7,018.4,Boo6,8,2.8
  1230. DATA 0201.3,-11.2,Spica,9,.96
  1231. DATA 0198.0,-07.5,Vir2,9,4.1
  1232. DATA 0195.5,011.0,Vindemiatrix,9,2.95
  1233. DATA 0193.9,003.4,Minelauva,9,3.66
  1234. DATA 0190.0,-01.0,Porrima,9,2.9
  1235. DATA 0185.0,000.0,Vir6,9,4.0
  1236. DATA 0177.0,002.0,Zavijah,9,3.8
  1237. DATA 0191.9,-59.7,Cru1,10,1.5
  1238. DATA 0187.8,-57.1,Cru2,10,1.24
  1239. DATA 0186.7,-63.1,Cru3,10,2.09
  1240. DATA 0183.8,-58.8,Cru4,10,1.61
  1241. DATA 0177.3,014.5,Denebola,11,2.23
  1242. DATA 0168.6,015.4,Coxa,11,3.41
  1243. DATA 0168.5,020.5,Zosma,11,2.58
  1244. DATA 0155.0,019.9,Algieba,11,2.06
  1245. DATA 0152.1,012.0,Regulus,11,1.36
  1246. DATA 0151.8,016.8,Leo7,11,3.65
  1247. DATA 0146.5,023.8,Ras Ela.Australis,11,3.12
  1248. DATA 0116.3,028.0,Pollux,12,1.15
  1249. DATA 0113.7,031.9,Kastor,12,1.95
  1250. DATA 0101.3,012.9,Gem3,12,3.4
  1251. DATA 0101.0,025.1,Gem4,12,3.18
  1252. DATA 0099.4,016.4,Gem5,12,1.93
  1253. DATA 0095.7,022.5,Gem6,12,3.19
  1254. DATA 0111.0,-29.3,Aludra,13,2.43
  1255. DATA 0107.1,-26.4,Wezen,13,1.84
  1256. DATA 0104.7,-29.0,Adara,13,1.78
  1257. DATA 0101.3,-16.7,Sirius,13,-1.47
  1258. DATA 0098.2,-18.0,Mirzam,13,1.97
  1259. DATA 0090.0,037.2,Aur1,14,2.7
  1260. DATA 0089.0,045.0,Menkalinan,14,1.9
  1261. DATA 0079.2,046.0,Capella,14,0.09
  1262. DATA 0075.5,043.8,Aur4,14,3.3
  1263. DATA 0074.3,033.2,Hassaleh,14,2.9
  1264. DATA 0088.8,007.4,Beteigeuze,15,.8
  1265. DATA 0086.9,-09.1,Ori2,15,2.2
  1266. DATA 0085.2,-02.0,Ori3,15,1.78
  1267. DATA 0084.1,-01.2,Alnilam,15,3.87
  1268. DATA 0083.0,-00.3,Mintaka,15,1.78
  1269. DATA 0081.3,006.4,Bellatrix,15,1.7
  1270. DATA 0078.6,-08.2,Rigel,15,.08
  1271. DATA 0059.5,040.0,Per1,16,2.96
  1272. DATA 0058.5,031.9,Per2,16,2.91
  1273. DATA 0055.7,047.8,Per3,16,3.1
  1274. DATA 0051.1,049.9,Mirfak,16,3.08
  1275. DATA 0047.0,041.0,Algol,16,2.2
  1276. DATA 0046.2,053.5,Miram,16,3.93
  1277. DATA 0031.0,042.0,Alamak,17,2.13
  1278. DATA 0017.4,035.6,Mirach,17,2.37
  1279. DATA 0009.1,030.8,And3,17,3.49
  1280. DATA 0002.1,029.1,Sirrah,17,2.15
  1281. DATA 0345.8,077.6,Cep1,18,3.42
  1282. DATA 0342.5,066.0,Cep2,18,3.68
  1283. DATA 0322.2,070.6,Alfrik,18,3.32
  1284. DATA 0319.6,062.6,Alderamin,18,2.6
  1285. DATA 0269.2,051.5,Etamin,19,2.42
  1286. DATA 0262.6,052.3,Alwaid,19,2.99
  1287. DATA 0231.2,059.0,Dra3,19,3.47
  1288. DATA 0246.0,061.6,Dra4,19,2.89
  1289. DATA 0172.5,069.7,Gianfar,19,4.06
  1290. DATA 0257.2,065.7,Nodus01,19,3.22
  1291. DATA 0268.5,056.9,Grumium,19,3.9
  1292. DATA 0288.1,067.7,Nodus02,19,3.24
  1293. DATA 0031.8,023.5,Hamal,20,2.0
  1294. DATA 0028.7,020.8,Scheratain,20,2.75
  1295. DATA 0028.5,019.3,Mesarthim,20,4.0
  1296. DATA 0084.4,021.2,Tau1,21,3.0
  1297. DATA 0081.6,028.6,Elnath,21,1.65
  1298. DATA 0069.0,016.5,Aldebaran,21,.86
  1299. DATA 0058.8,012.5,Tau4,21,3.8
  1300. DATA 0056.9,024.1,Plejaden,21,0
  1301. DATA 0114.8,005.2,Prokyon,22,.34
  1302. DATA 0111.8,008.3,Gomeisa,22,3.09
  1303. DATA 0331.4,-00.3,Sadalmelek,23,3.1
  1304. DATA 0322.9,-05.6,Sadalsud,23,3.07
  1305. DATA 0343.7,-15.8,Skat,23,3.51
  1306. DATA 0311.8,-09.7,Albali,23,3.83
  1307. DATA 0337.0,-00.3,Aqu6,23,3.75
  1308. DATA 0331.3,-14.0,Aqu7,23,4.21
  1309. DATA 0343.0,-07.8,Aqu8,23,3.84
  1310. DATA 0347.0,-20.4,Aqu9,23,4.2
  1311. DATA 0194.1,038.3,Chara,24,2.9
  1312. DATA 0188.5,041.4,Cvn2,24,4.32
  1313. DATA 0304.5,-12.5,Algedi,25,3.35
  1314. DATA 0305.3,-14.8,Dabih,25,3.25
  1315. DATA 0325.0,-16.7,Nashira,25,3.8
  1316. DATA 0326.8,-16.1,Deneb Algiedi,25,2.98
  1317. DATA 0321.7,-22.4,Cap5,25,3.86
  1318. DATA 0316.5,-17.3,Cap6,25,4.1
  1319. DATA 0219.9,-60.8,Toliman,26,.33
  1320. DATA 0211.0,-60.4,Cen2,26,.59
  1321. DATA 0190.4,-49.0,Cen3,26,2.38
  1322. DATA 0182.2,-50.7,Cen4,26,2.88
  1323. DATA 0205.0,-53.5,Cen5,26,2.56
  1324. DATA 0200.1,-36.7,Cen6,26,3.3
  1325. DATA 0208.9,-44.3,Cen7,26,2.65
  1326. DATA 0211.7,-36.4,Cen8,26,3.3
  1327. DATA 0045.6,004.1,Menkar,27,2.82
  1328. DATA 0010.9,-18.0,Deneb Kaitos,27,2.24
  1329. DATA 0034.8,-03.0,Mira,27,2.0
  1330. DATA 0026.0,-15.9,Tau Ceti,27,3.65
  1331. DATA 0084.9,-34.1,Phakt,28,2.75
  1332. DATA 0087.7,-35.8,Col2,28,3.22
  1333. DATA 0233.7,026.7,Gemma,29,2.31
  1334. DATA 0232.0,029.4,Nusakan,29,3.72
  1335. DATA 0188.6,-23.4,Crv2,30,2.84
  1336. DATA 0183.9,-17.5,Crv3,30,2.78
  1337. DATA 0187.5,-16.5,Crv4,30,3.11
  1338. DATA 0182.5,-22.6,Crv5,30,3.21
  1339. DATA 0024.4,-57.3,Achernar,31,.47
  1340. DATA 0077.0,-05.1,Cursa,31,2.92
  1341. DATA 0059.5,-13.5,Zaurak,31,3.19
  1342. DATA 0055.8,-09.8,Rana,31,3.72
  1343. DATA 0069.2,-30.5,Theemin,31,3.88
  1344. DATA 0258.7,014.4,Ras Algethi,32,3.5
  1345. DATA 0247.6,021.5,Rutilicus,32,2.81
  1346. DATA 0258.8,024.8,Sarin,32,3.16
  1347. DATA 0250.3,031.6,Her4,32,3.0
  1348. DATA 0258.8,036.8,Her5,32,3.36
  1349. DATA 0266.6,027.7,Her6,32,3.48
  1350. DATA 0141.9,-08.7,Alfard,33,1.98
  1351. DATA 0131.7,006.4,Hya2,33,3.48
  1352. DATA 00133.9,006.0,Hya3,33,3.3
  1353. DATA 0162.4,-16.2,Hya4,33,3.32
  1354. DATA 0199.7,-23.2,Hya5,33,3.33
  1355. DATA 0202.4,-23.3,Hya6,33,3.48
  1356. DATA 0211.6,-26.7,Hya7,33,3.48
  1357. DATA 0083.2,-17.8,Arneb,34,2.69
  1358. DATA 0082.1,-20.8,Nihal,34,2.96
  1359. DATA 0078.2,-16.2,Lep3,34,3.29
  1360. DATA 0222.7,-16.1,Zuben Algenubi,35,2.9
  1361. DATA 0229.3,-09.4,Zuben Elschemali,35,2.74
  1362. DATA 0226.0,-25.3,Lib3,35,3.41
  1363. DATA 0220.5,-47.4,Lup1,36,3.61
  1364. DATA 0224.6,-43.1,Lup2,36,3.59
  1365. DATA 0233.8,-41.2,Lup3,36,4.1
  1366. DATA 0263.7,012.6,Ras Alhague,37,2.14
  1367. DATA 0265.9,004.6,Kelb al Rai,37,2.94
  1368. DATA 0243.6,-03.7,Yed Prior,37,3.03
  1369. DATA 0249.3,-10.6,Oph4,37,2.7
  1370. DATA 0257.6,-15.7,Sabik,37,2.63
  1371. DATA 0269.8,-09.8,Oph5,37,3.5
  1372. DATA 0030.2,002.5,Kaitain,38,3.94
  1373. DATA 0349.0,003.1,Psc2,38,3.85
  1374. DATA 0344.4,-29.6,Fomalhaut,39,1.16
  1375. DATA 0271.5,-30.1,Nash,40,3.07
  1376. DATA 0275.3,-29.8,Kaus Medius,40,2.84
  1377. DATA 0276.0,-34.4,Kaus Australis,40,1.82
  1378. DATA 0285.7,-29.9,Ascella,40,2.71
  1379. DATA 0277.0,-25.4,Kaus Borealis,40,2.94
  1380. DATA 0274.4,-36.8,Sgr6,40,3.16
  1381. DATA 0283.8,-26.3,Nunki,40,3.08
  1382. DATA 0287.4,-21.0,Sgr8,40,3.61
  1383. DATA 0286.7,-27.7,Sgr9,40,3.42
  1384. DATA 0281.4,-27.0,Sgr10,40,3.3
  1385. DATA 0236.1,006.4,Unuk,41,2.75
  1386. DATA 0275.3,-02.9,Ser2,41,3.42
  1387. DATA 0237.5,-03.3,Ser3,41,3.63
  1388. DATA 0028.3,029.5,Metallah,42,3.58
  1389. DATA 0032.4,035.0,Tri2,42,3.08
  1390. DATA 0034.3,033.8,Tri3,42,4.07
  1391. DATA 0189.3,-69.1,Mus1,43,2.94
  1392. DATA 0191.6,-68.1,Mus2,43,3.26
  1393. DATA 0006.6,-42.3,Phe1,44,2.44
  1394. DATA 0016.5,-46.4,Phe2,44,3.35
  1395. DATA 0022.1,-46.3,Phe3,44,3.4
  1396. DATA 0252.2,-69.0,Tra1,45,1.88
  1397. DATA 0238.8,-63.4,Tra2,45,3.04
  1398. DATA 0229.7,-68.7,Tra3,45,3.06
  1399. DATA 0334.6,-60.3,Tuc1,46,2.91
  1400. DATA 0263.0,-49.9,Ara1,47,2.97
  1401. DATA 0261.3,-55.5,Ara2,47,2.8
  1402. DATA 0096.0,-52.7,Canopus,48,-.73
  1403. DATA 0138.3,-69.7,Car2,48,1.8
  1404. DATA 0125.6,-59.5,Car3,48,1.74
  1405. DATA 0161.3,-59.7,Car4,48,-1
  1406. DATA 0332.1,-47.0,Alnair,49,2.16
  1407. DATA 0340.7,-46.9,Gru2,49,2.24
  1408. DATA 0122.4,-47.4,Vel1,50,2.22
  1409. DATA 0131.2,-54.7,Vel2,50,2.01
  1410. constellations:
  1411. DATA Ursa minor,Kleiner Wagem,6,1
  1412. DATA Ursa major,Großer Wagen,6,8
  1413. DATA Cassiopeia,Kassiopeia,4,15
  1414. DATA Pegasus,Pegasus,5,20
  1415. DATA Cygnus,Schwan,4,26
  1416. DATA Aquilla,Adler,6,31
  1417. DATA Lyra,Leier,4,38
  1418. DATA Scorpius,Skorpion,9,43
  1419. DATA Bootes,Bootes,6,53
  1420. DATA Virgo,Jungfrau,6,60
  1421. DATA Crux,Kreuz des Südens,3,67
  1422. DATA Leo,Löwe,6,71
  1423. DATA Gemini,Zwillinge,5,78
  1424. DATA Canis major,Großer Hund,4,84
  1425. DATA Auriga,Fuhrmann,4,89
  1426. DATA Orion,Orion,6,94
  1427. DATA Perseus,Perseus,5,101
  1428. DATA Andromeda,Andromeda,3,107
  1429. DATA Cepheus,Kepheus,3,111
  1430. DATA Draco,Drache,7,115
  1431. DATA Aries,Widder,2,123
  1432. DATA Taurus,Stier,4,126
  1433. DATA Canis minor,Kleiner Hund,1,131
  1434. DATA Aquarius,Wassermann,7,133
  1435. DATA Canes venatici,Jagdhunde,1,141
  1436. DATA Capricornus,Steinbock,5,143
  1437. DATA Centaurus,Zentaur,7,149
  1438. DATA Cetus,Walfisch,3,157
  1439. DATA Columba,Taube,1,161
  1440. DATA Corona borealis,Krone,1,163
  1441. DATA Corvus,Rabe,3,165
  1442. DATA Eridanus,Eridanus,4,169
  1443. DATA Hercules,Herkules,5,174
  1444. DATA Hydra,Wasserschlange,6,180
  1445. DATA Lepus,Hase,2,187
  1446. DATA Libra,Waage,2,190
  1447. DATA Lupus,Wolf,2,193
  1448. DATA Ophiochus,Schlangenträger,5,196
  1449. DATA Pisces,Fische,1,202
  1450. DATA Piscis australis,Süd. Fisch,0,204
  1451. DATA Sagittarius,Schütze,9,205
  1452. DATA Serpens,Schlange,2,215
  1453. DATA Triangulum,Dreieck,2,218
  1454. DATA Musca,Fliege,1,221
  1455. DATA Phoenix,Phönix,2,223
  1456. DATA Triang.aust.,Südl.Dreieck,2,226
  1457. DATA Tucana,Tukan,0,229
  1458. DATA Ara,Ara,1,230
  1459. DATA Carina,Kiel,3,232
  1460. DATA Grus,Kranich,1,236
  1461. DATA Vela,Segel,1,238
  1462. planets:
  1463. DATA Merkur,4.0923,31.19,76.987
  1464. DATA 23.00,.2056,47.826,7.004,.3871
  1465. DATA Venus,1.6021,80.85,131.149
  1466. DATA .76,.0068,76.410,3.394,.7233
  1467. DATA Mars,.5240,144.14,335.507
  1468. DATA 11.00,.0934,49.326,1.850,1.5237
  1469. DATA Jupiter,.0831,316.19,13.839
  1470. DATA 5.30,.0485,100.146,1.305,5.2028
  1471. DATA Saturn,.0335,158.36,92.460
  1472. DATA 5.50,.0557,113.511,2.486,9.5810
  1473. DATA Uranus,.0117,98.38,170.173
  1474. DATA 5.70,.0472,73.847,.773,19.1823
  1475. '
  1476. men1:
  1477. DATA  Program,continue     ,quit  ,about....,! author: Rolf Kühr,!         Am Südhang 21,!         D4798 Wünnenberg,!         Version 1.13i,
  1478. DATA  Change parameters,  Location......    ,  Date/Time.....    ,  Pre-set locations    ,!  Wünnenberg,!  Berlin,!  Moskow,!  New York,!  Arctic Pole,!  Antarctic Pole,!  Quito (equator),  System-time....  ,
  1479. DATA  Mode,  Star chart       ,-  Planetarium     ,-  Telescope,
  1480. DATA  Resolution,  640*240     ,  640*480     ,
  1481. DATA  Look for,- name     ,
  1482. DATA  Print,- hardcopy           ,-  names in chart
  1483. DATA ENDE
  1484. '
  1485. availobjects:
  1486. DATA Uranus,Jupiter,Saturn,Merkur,Mars,Jagdhunde,Orion,Plejaden
  1487. DATA ENDE
  1488. '
  1489. '       LOAD ACBM :Program to load Amiga-Continues-BitMap
  1490. '
  1491. '       <C> 1989 by GFA Systemtechnik GmbH.
  1492. '
  1493. ' ****************************************************************
  1494. '
  1495. ' 28.8.89
  1496. '
  1497. '
  1498. PROCEDURE load_acbm(bild$,f|)
  1499.   IF bild$<>"" AND RIGHT$(bild$,1)<>":" AND EXIST(bild$)
  1500.     OPEN "i",#1,bild$
  1501.     '
  1502.     mybuf%=AllocMem(360,65537)
  1503.     IF mybuf%=0
  1504.       ALERT 0,"Not enough memory",0,"OK",v&
  1505.       END
  1506.     ENDIF
  1507.     inbuf%=mybuf%
  1508.     cbuf%=ADD(mybuf%,120)
  1509.     ctab%=ADD(mybuf%,240)
  1510.     BGET #1,inbuf%,12
  1511.     IF MKL$({ADD(inbuf%,8)})<>"ILBM" AND MKL$({ADD(inbuf%,8)})<>"ACBM"
  1512.       ALERT 0,"No ILBM file !",0,"OK",v&
  1513.       CLOSE #1
  1514.     ELSE
  1515.       CLR bmhd!,cmap!,body!
  1516.       '
  1517.       WHILE NOT EOF(#1) OR (bmhd! AND cmap! AND body!)
  1518.         BGET #1,inbuf%,8
  1519.         len%={ADD(inbuf%,4)}
  1520.         SELECT MKL$({inbuf%})
  1521.         CASE "BMHD"
  1522.           @read_bmhd
  1523.           bmhd!=TRUE
  1524.         CASE "CMAP"
  1525.           @read_cmap
  1526.           cmap!=TRUE
  1527.         CASE "CAMG"
  1528.           @read_camg
  1529.           camg!=TRUE
  1530.         CASE "ABIT"
  1531.           @read_abit
  1532.           abit!=TRUE
  1533.         DEFAULT
  1534.           RELSEEK #1,len%-ODD(len%)   ! skip unknown chunk
  1535.         ENDSELECT
  1536.       WEND
  1537.       CLOSE #1
  1538.       '
  1539.     ENDIF
  1540.     mybuf%=FreeMem(mybuf%,360)
  1541.   ELSE
  1542.     exit!=TRUE
  1543.   ENDIF
  1544. RETURN
  1545. PROCEDURE read_bmhd
  1546.   BGET #1,inbuf%,len%
  1547.   w&=CARD{inbuf%}
  1548.   h&=CARD{ADD(inbuf%,2)}
  1549.   d|=BYTE{ADD(inbuf%,8)}
  1550.   c|=BYTE{ADD(inbuf%,10)}
  1551.   sw&=CARD{ADD(inbuf%,16)}
  1552.   sh&=CARD{ADD(inbuf%,18)}
  1553.   rb&=SHR(w&,3)
  1554.   srb&=SHR(sw&,3)
  1555.   cols&=BSET(0,d|)
  1556.   IF camg!
  1557.     v%=camg%
  1558.   ELSE
  1559.     CLR v%
  1560.     IF sw&>320
  1561.       v%=OR(v%,&H8000)
  1562.     ENDIF
  1563.     IF sh&>256
  1564.       v%=OR(v%,4)
  1565.     ENDIF
  1566.   ENDIF
  1567.   IF WINDOW(f|)=0               ! Fenster geöffnet?
  1568.     OPENS 7,0,0,sw&,sh&,d|,v%
  1569.     DISPLAY OFF
  1570.   ENDIF
  1571.   mem%=v%
  1572. RETURN
  1573. PROCEDURE read_cmap
  1574.   LOCAL v&
  1575.   cmap!=TRUE
  1576.   BGET #1,cbuf%,len%
  1577.   FOR v&=0 TO PRED(cols&)
  1578.     v%=ADD(cbuf%,MUL(3,v&))
  1579.     r|=BYTE{v%}
  1580.     g|=BYTE{SUCC(v%)}
  1581.     b|=BYTE{ADD(v%,2)}
  1582.     '
  1583.     CARD{ADD(ctab%,ADD(v&,v&))}=ADD(ADD(g|,SHL(r|,4)),SHR(b|,4))
  1584.     SETCOLOR v&,CARD{ADD(ctab%,v&*2)}
  1585.   NEXT v&
  1586. RETURN
  1587. PROCEDURE read_camg
  1588.   camg!=TRUE
  1589.   BGET #1,inbuf%,len%
  1590.   camg%=LONG{inbuf%}
  1591. RETURN
  1592. PROCEDURE read_abit
  1593.   LOCAL mem|,wad%
  1594.   '
  1595.   mem|=0
  1596.   bpl%=MUL(h&,SHR(w&,3))
  1597.   wad%=WINDOW(f|)
  1598.   IF wad%                        ! In Fenster kopieren
  1599.     bm%=LONG{LONG{wad%+50}+4}
  1600.     dl|=MIN(d|,BYTE{bm%+5})      ! Bitplanes
  1601.     wl&=MIN(sw&,CARD{wad%+8})
  1602.     hl&=MIN(sh&,CARD{wad%+10})
  1603.     '
  1604.     a|=BYTE{wad%+54}             ! Borders ?
  1605.     IF wl&+a|>CARD{wad%+8}
  1606.       SUB wl&,a|
  1607.     ENDIF
  1608.     xof%=a|
  1609.     '
  1610.     a|=BYTE{wad%+55}
  1611.     IF hl&+a|>CARD{wad%+10}
  1612.       SUB hl&,a|+3
  1613.     ENDIF
  1614.     yof%=a|
  1615.     '
  1616.     a|=BYTE{wad%+56}
  1617.     IF wl&+a|+BYTE{wad%+54}>CARD{wad%+8}
  1618.       SUB wl&,a|
  1619.     ENDIF
  1620.     '
  1621.     a|=BYTE{wad%+57}
  1622.     IF hl&+a|+BYTE{wad%+55}>CARD{wad%+10}
  1623.       SUB hl&,a|
  1624.     ENDIF
  1625.     '
  1626.     ADD xof%,CARD{wad%+4}
  1627.     ADD yof%,CARD{wad%+6}
  1628.     INLINE bm2%,40
  1629.     CARD{bm2%}=srb&
  1630.     CARD{bm2%+2}=sh&
  1631.     BYTE{bm2%+4}=0
  1632.     BYTE{bm2%+5}=dl|
  1633.     BYTE{bm2%+6}=0
  1634.     '
  1635.     FOR mem|=1 TO d|                    ! Einlesen
  1636.       IF mem|<=dl|
  1637.         bpad%=AllocMem(bpl%,3)
  1638.         LONG{bm2%+4+mem|*4}=bpad%
  1639.         BGET #1,bpad%,bpl%
  1640.       ELSE
  1641.         RELSEEK #1,bpl%
  1642.       ENDIF
  1643.     NEXT mem|
  1644.     '
  1645.     ~BltBitMap(bm2%,0,0,bm%,xof%,yof%,wl&,hl&,&HC0,&H3F,0)
  1646.     '
  1647.     FOR mem|=1 TO dl|
  1648.       ~FreeMem(LONG{bm2%+4+mem|*4},bpl%)
  1649.     NEXT mem|
  1650.   ELSE
  1651.     REPEAT
  1652.       bpad%=LONG{ADD(SCREEN(7),ADD(192,SHL(mem|,2)))}
  1653.       BGET #1,bpad%,bpl%
  1654.       INC mem|
  1655.     UNTIL mem|=d|
  1656.   ENDIF
  1657. RETURN
  1658.